home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / inline.lisp < prev    next >
Lisp/Scheme  |  1992-09-01  |  9KB  |  264 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2.  
  3. (in-package :pcl)
  4.  
  5. ;; This file contains some of the things that will have to change to support
  6. ;; inlining of methods.
  7.  
  8. (defun make-method-lambda-internal (method-lambda &optional env)
  9.   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
  10.     (error "The method-lambda argument to make-method-lambda, ~S,~
  11.             is not a lambda form" method-lambda))
  12.   (multiple-value-bind (documentation declarations real-body)
  13.       (extract-declarations (cddr method-lambda) env)
  14.     (let* ((name-decl (get-declaration 'method-name declarations))
  15.        (sll-decl (get-declaration 'method-lambda-list declarations))
  16.        (method-name (when (consp name-decl) (car name-decl)))
  17.        (generic-function-name (when method-name (car method-name)))
  18.        (specialized-lambda-list (or sll-decl (cadr method-lambda))))
  19.       (multiple-value-bind (parameters lambda-list specializers)
  20.       (parse-specialized-lambda-list specialized-lambda-list)
  21.     (let* ((required-parameters
  22.         (mapcar #'(lambda (r s) (declare (ignore s)) r)
  23.             parameters
  24.             specializers))
  25.            (slots (mapcar #'list required-parameters))
  26.            (calls (list nil))
  27.            (parameters-to-reference
  28.         (make-parameter-references specialized-lambda-list
  29.                        required-parameters
  30.                        declarations
  31.                        method-name
  32.                        specializers))
  33.            (class-declarations
  34.         `(declare
  35.           ,@(remove nil
  36.                 (mapcar #'(lambda (a s) (and (symbolp s)
  37.                              (neq s 't)
  38.                              `(class ,a ,s)))
  39.                     parameters
  40.                     specializers))))
  41.            (method-lambda
  42.           ;; Remove the documentation string and insert the
  43.           ;; appropriate class declarations.  The documentation
  44.           ;; string is removed to make it easy for us to insert
  45.           ;; new declarations later, they will just go after the
  46.           ;; cadr of the method lambda.  The class declarations
  47.           ;; are inserted to communicate the class of the method's
  48.           ;; arguments to the code walk.
  49.           `(lambda ,lambda-list
  50.              ,class-declarations
  51.              ,@declarations
  52.              (progn ,@parameters-to-reference)
  53.              (block ,(if (listp generic-function-name)
  54.                  (cadr generic-function-name)
  55.                  generic-function-name)
  56.                ,@real-body)))
  57.            (constant-value-p (and (null (cdr real-body))
  58.                       (constantp (car real-body))))
  59.            (constant-value (and constant-value-p
  60.                     (eval (car real-body))))
  61.            (plist (if (and constant-value-p
  62.                    (or (typep constant-value '(or number character))
  63.                    (and (symbolp constant-value)
  64.                     (symbol-package constant-value))))
  65.               (list :constant-value constant-value)
  66.               ()))
  67.            (applyp (dolist (p lambda-list nil)
  68.              (cond ((memq p '(&optional &rest &key))
  69.                 (return t))
  70.                    ((eq p '&aux)
  71.                 (return nil))))))
  72.         (multiple-value-bind (walked-lambda call-next-method-p closurep
  73.                         next-method-p-p)
  74.         (walk-method-lambda method-lambda required-parameters env 
  75.                     slots calls)
  76.           (multiple-value-bind (ignore walked-declarations walked-lambda-body)
  77.           (extract-declarations (cddr walked-lambda))
  78.         (declare (ignore ignore))
  79.         (when (or next-method-p-p call-next-method-p)
  80.           (setq plist (list* :needs-next-methods-p 't plist)))
  81.         (when (some #'cdr slots)
  82.           (multiple-value-bind (slot-name-lists call-list)
  83.               (slot-name-lists-from-slots slots calls)
  84.             (let ((pv-table-symbol (make-symbol "pv-table")))
  85.               (setq plist 
  86.                 `(,@(when slot-name-lists 
  87.                   `(:slot-name-lists ,slot-name-lists))
  88.                   ,@(when call-list
  89.                   `(:call-list ,call-list))
  90.                   :pv-table-symbol ,pv-table-symbol
  91.                   ,@plist))
  92.               (setq walked-lambda-body
  93.                 `((pv-binding (,required-parameters ,slot-name-lists
  94.                        ,pv-table-symbol)
  95.                    ,@walked-lambda-body))))))
  96.         (when (and (memq '&key lambda-list)
  97.                (not (memq '&allow-other-keys lambda-list)))
  98.           (let ((aux (memq '&aux lambda-list)))
  99.             (setq lambda-list (nconc (ldiff lambda-list aux)
  100.                          (list '&allow-other-keys)
  101.                          aux))))
  102.         (values `(lambda (.method-args. .next-methods.)
  103.                (simple-lexical-method-functions
  104.                    (,lambda-list .method-args. .next-methods.
  105.                 :call-next-method-p ,call-next-method-p 
  106.                 :next-method-p-p ,next-method-p-p
  107.                 :closurep ,closurep
  108.                 :applyp ,applyp)
  109.                  ,@walked-declarations
  110.                  ,@walked-lambda-body))
  111.             `(,@(when plist 
  112.                   `(:plist ,plist))
  113.               ,@(when documentation 
  114.                   `(:documentation ,documentation)))))))))))
  115.  
  116. (define-inline-function slot-value (instance slot-name) (form closure-p env)
  117.   :predicate (and (not closure-p) (constantp slot-name))
  118.   :inline-arguments (required-parameters slots)
  119.   :inline (optimize-slot-value     
  120.        slots
  121.        (can-optimize-access form required-parameters env)
  122.        form))
  123.  
  124. ;collect information about:
  125. ; uses of the required-parameters
  126. ; uses of call-next-method and next-method-p:
  127. ;   called-p
  128. ;   apply-p
  129. ;   arglist info
  130. ;optimize calls to slot-value, set-slot-value, slot-boundp
  131. ;optimize calls to find-class
  132. ;optimize generic-function calls
  133. (defun make-walk-function (required-parameters info slots calls)
  134.   #'(lambda (form context env)
  135.       (cond ((not (eq context ':eval)) form)
  136.         ((not (listp form)) form)
  137.         ((eq (car form) 'call-next-method)
  138.          (setq call-next-method-p 't)
  139.          form)
  140.         ((eq (car form) 'next-method-p)
  141.          (setq next-method-p-p 't)
  142.          form)
  143.         ((and (eq (car form) 'function)
  144.           (cond ((eq (cadr form) 'call-next-method)
  145.              (setq call-next-method-p 't)
  146.              (setq closurep t)
  147.              form)
  148.             ((eq (cadr form) 'next-method-p)
  149.              (setq next-method-p-p 't)
  150.              (setq closurep t)
  151.              form)
  152.             (t nil))))
  153.         ((and (or (eq (car form) 'slot-value)
  154.               (eq (car form) 'set-slot-value)
  155.               (eq (car form) 'slot-boundp))
  156.           (constantp (caddr form)))
  157.          (let ((parameter
  158.             (can-optimize-access form
  159.                      required-parameters env)))
  160.            (ecase (car form)
  161.          (slot-value
  162.           (optimize-slot-value     slots parameter form))
  163.          (set-slot-value
  164.           (optimize-set-slot-value slots parameter form))
  165.          (slot-boundp
  166.           (optimize-slot-boundp    slots parameter form)))))
  167.         ((and (or (symbolp (car form))
  168.               (and (consp (car form))
  169.                (eq (caar form) 'setf)))
  170.           (gboundp (car form))
  171.           (if (eq *boot-state* 'complete)
  172.               (standard-generic-function-p (gdefinition (car form)))
  173.               (funcallable-instance-p (gdefinition (car form)))))
  174.          (optimize-generic-function-call 
  175.           form required-parameters env slots calls))
  176.         (t form))))
  177.  
  178. (defun walk-method-lambda (method-lambda required-parameters env slots calls)
  179.   (let* ((call-next-method-p nil)   ;flag indicating that call-next-method
  180.                     ;should be in the method definition
  181.      (closurep nil)            ;flag indicating that #'call-next-method
  182.                     ;was seen in the body of a method
  183.      (next-method-p-p nil)      ;flag indicating that next-method-p
  184.                     ;should be in the method definition
  185.      (walk-functions `((call-next-method-p
  186.                 ,#'(lambda (form closure-p env)
  187.                  (setq call-next-method-p 't)
  188.                  (when closure-p
  189.                    (setq closurep t))
  190.                  form))
  191.                (next-method-p
  192.                 ,#'(lambda (form closure-p env)
  193.                  (setq next-method-p-p 't)
  194.                  (when closure-p
  195.                    (setq closurep t))
  196.                  form))
  197.                ((slot-value set-slot-value slot-boundp)
  198.                 ,#'(lambda (form closure-p env)
  199.                  (if (and (not closure-p)
  200.                       (constantp (caddr form)))
  201.                      
  202.     (let ((walked-lambda (walk-form method-lambda env 
  203.                     (make-walk-function 
  204.                      `((call-next-method-p
  205.                     ,#'(lambda (form closure-p env)
  206.                          (setq call-next-method-p 't)
  207.                          (when closure-p
  208.                            (setq closurep t))
  209.                          form))
  210.                        (next-method-p
  211.                     ,#'(lambda (form closure-p env)
  212.                          (setq next-method-p-p 't)
  213.                          (when closure-p
  214.                            (setq closurep t))
  215.                          form))
  216.                        ((slot-value set-slot-value slot-boundp)
  217.                     ,#'(lambda (form closure-p env)
  218.                          (
  219.       (values walked-lambda
  220.           call-next-method-p closurep next-method-p-p)))))
  221.  
  222. (defun initialize-method-function (initargs &optional return-function-p method)
  223.   (let* ((mf (getf initargs ':function))
  224.      (method-spec (getf initargs ':method-spec))
  225.      (plist (getf initargs ':plist))
  226.      (pv-table-symbol (getf plist ':pv-table-symbol))
  227.      (pv-table nil)
  228.      (mff (getf initargs ':fast-function)))
  229.     (flet ((set-mf-property (p v)
  230.          (when mf
  231.            (setf (method-function-get mf p) v))
  232.          (when mff
  233.            (setf (method-function-get mff p) v))))
  234.       (when method-spec
  235.     (when mf
  236.       (setq mf (set-function-name mf method-spec)))
  237.     (when mff
  238.       (let ((name `(,(or (get (car method-spec) 'fast-sym)
  239.                  (setf (get (car method-spec) 'fast-sym)
  240.                    (intern (format nil "FAST-~A"
  241.                            (car method-spec))
  242.                        *the-pcl-package*)))
  243.              ,@(cdr method-spec))))
  244.         (set-function-name mff name)
  245.         (unless mf
  246.           (set-mf-property :name name)))))
  247.       (when plist
  248.     (let ((snl (getf plist :slot-name-lists))
  249.           (cl (getf plist :call-list)))
  250.       (when (or snl cl)
  251.         (setq pv-table (intern-pv-table :slot-name-lists snl
  252.                         :call-list cl))
  253.         (when pv-table (set pv-table-symbol pv-table))
  254.         (set-mf-property :pv-table pv-table)))    
  255.     (loop (when (null plist) (return nil))
  256.           (set-mf-property (pop plist) (pop plist)))      
  257.     (when method
  258.       (set-mf-property :method method))    
  259.     (when return-function-p
  260.       (or mf (method-function-from-fast-function mff)))))))
  261.  
  262.  
  263.  
  264.